[PATCH] Add more flexible instantiation syntax for `new`

---
 collects/racket/private/class-internal.rkt |   41 ++++++++++++++++------------
 1 file changed, 24 insertions(+), 17 deletions(-)

diff --git a/collects/racket/private/class-internal.rkt b/collects/racket/private/class-internal.rkt
index 2c03780..57d08e7 100644
--- a/collects/racket/private/class-internal.rkt
+++ b/collects/racket/private/class-internal.rkt
@@ -3808,24 +3808,31 @@ An example
 ;;  instantiation
 ;;--------------------------------------------------------------------
 
+;; class instantiation syntax, allows mixed keywords and positionals
 (define-syntax (new stx)
-  (syntax-case stx ()
-    [(_ cls (id arg) ...)
-     (andmap identifier? (syntax->list (syntax (id ...))))
-     (quasisyntax/loc stx
-       (instantiate cls () (id arg) ...))]
-    [(_ cls (id arg) ...)
-     (for-each (lambda (id)
-                 (unless (identifier? id)
-                   (raise-syntax-error 'new "expected identifier" stx id)))
-               (syntax->list (syntax (id ...))))]
-    [(_ cls pr ...)
-     (for-each
-      (lambda (pr)
-        (syntax-case pr ()
-          [(x y) (void)]
-          [else (raise-syntax-error 'new "expected name and value binding" stx pr)]))
-      (syntax->list (syntax (pr ...))))]))
+  (syntax-parse stx
+    [(_ cls arg ...)
+     (define-values (kw-args pos-args)
+       (parse-init-args #'(arg ...)))
+     (with-syntax ([(kw ...) kw-args]
+                   [(pos ...) pos-args])
+      (quasisyntax/loc stx
+        (instantiate cls (pos ...) kw ...)))]))
+
+(begin-for-syntax
+ ;; listof<syntax> -> (values listof<syntax> listof<syntax>)
+ ;; parses arguments for `new` and collects them into two lists
+ (define (parse-init-args stx)
+   (define stxs (syntax->list stx))
+   (define-values (kw-args pos-args)
+     (for/fold ([kw-args '()]
+                [pos-args '()])
+               ([stx stxs])
+       (syntax-parse stx
+         [(kw:id arg)
+          (values (cons stx kw-args) pos-args)]
+         [arg (values kw-args (cons stx pos-args))])))
+   (values kw-args (reverse pos-args))))
 
 (define ((make-object/proc blame) class . args)
   (do-make-object blame class args null))
-- 
1.7.10.4


--Fba/0zbH8Xs+Fj9o--