Implemented Sam's suggested changes for new forms, and added a new match/values form.

collects/racket/match/define-forms.rkt

@@ -12,18 +12,42 @@
 
 (provide define-forms)
 
+;; each pat matches a value in a multi-valued expression
+(define-for-syntax (match-values-clause->let-clause pats rhs)
+  (with-syntax ([(pats ...) pats]
+                [(ids ...) (generate-temporaries pats)])
+    ;; rhs evaluates to number of ids values.
+    ;; patterns should match against each id.
+    (values #'(ids ...)
+            #`[(ids ...) #,rhs])))
+
+(define-for-syntax (match-values-clauses->let-clauses patses rhses)
+  (for/lists (idses let-clauses)
+      ([pats (syntax->list patses)]
+       [rhs (syntax->list rhses)])
+    (match-values-clause->let-clause pats rhs)))
+
+(define-for-syntax (all-same-length stx-listses)
+  (let loop ([listses (syntax->list stx-listses)]
+             [the-length #f])
+    (cond [(null? listses) #t]
+          [the-length
+           (and (= the-length (length (syntax->list (car listses))))
+                (loop (cdr listses) the-length))]
+          [else (loop (cdr listses) (length (syntax->list (car listses))))])))
+
 (define-syntax-rule (define-forms parse-id
                       match match* match-lambda match-lambda*
 		      match-lambda** match-let match-let*
                       match-let-values match-let*-values
 		      match-define match-define-values match-letrec
-		      match/derived match*/derived)
+		      match/values match/derived match*/derived)
   (...
    (begin
      (provide match match* match-lambda match-lambda* match-lambda**
 	      match-let match-let* match-let-values match-let*-values
               match-define match-define-values match-letrec
-	      match/derived match*/derived match-define-values)
+	      match/values match/derived match*/derived match-define-values)
      (define-syntax (match* stx)
        (syntax-parse stx
          [(_ es . clauses)
@@ -44,6 +68,16 @@
          [(_ arg:expr orig-stx clauses ...)
           (go/one parse-id #'orig-stx #'arg #'(clauses ...))]))
 
+     (define-syntax (match/values stx)
+       (syntax-parse stx
+         [(_ arg:expr [(pats ...) rhs:expr] [(patses ...) rhses:expr] ...)
+          #:fail-unless (all-same-length #'((pats ...) (patses ...) ...))
+          "All clauses must have the same number of patterns"
+          (define-values (ids let-clause)
+            (match-values-clause->let-clause #'(pats ...) #'rhs))
+          #`(let-values ([#,ids arg])
+              (match*/derived #,ids #,stx [(pats ...) rhs] [(patses ...) rhses] ...))]))
+
      (define-syntax (match-lambda stx)
        (syntax-parse stx
          [(_ . clauses)
@@ -65,6 +99,29 @@
                          [body #`(match*/derived vars #,stx clauses ...)])
             (syntax/loc stx (lambda vars body)))]))
 
+
+     (define-syntax (match-let-values stx)
+       (syntax-parse stx
+         [(_ (~and clauses ([(patses ...) rhses:expr] ...)) body1 body ...)
+          (define-values (idses let-clauses)
+            (match-values-clauses->let-clauses #'((patses ...) ...) #'(rhses ...)))
+          #`(let-values #,let-clauses
+              (match*/derived #,(append-map syntax->list idses) #,stx
+                [(patses ... ...)
+                 (let () body1 body ...)]))]))
+
+     (define-syntax (match-let*-values stx)
+       (syntax-parse stx
+         [(_ () body1 body ...)
+          #'(let () body1 body ...)]
+         [(_ ([(pats ...) rhs] rest-pats ...) body1 body ...)
+          (define-values (ids let-clause)
+            (match-values-clause->let-clause #'(pats ...) #'rhs))
+          #`(let-values (#,let-clause)
+              (match*/derived #,ids #,stx
+               [(pats ...) #,(syntax/loc stx (match-let*-values (rest-pats ...)
+                               body1 body ...))]))]))
+
      ;; there's lots of duplication here to handle named let
      ;; some factoring out would do a lot of good
      (define-syntax (match-let stx)
@@ -76,46 +133,11 @@
 					 [(pat ...) (let () body1 body ...)])])
            #'(letrec ([nm (lambda vars loop-body)])
                (nm init-exp ...)))]
-         [(_ (~and clauses ([pat init-exp:expr] ...)) body1 body ...)
+         [(_ ([pat init-exp:expr] ...) body1 body ...)
-          #`(match*/derived (init-exp ...) #,stx
+          #`(match-let-values ([(pat) init-exp] ...) body1 body ...)]))
-			    [(pat ...) (let () body1 body ...)])]))
-
-     (define-syntax (match-let* stx)
-       (syntax-parse stx
-         [(_ () body1 body ...)
-          #'(let () body1 body ...)]
-         [(_ ([pat exp] rest-pats ...) body1 body ...)
-          #`(match*/derived
-             (exp)
-             #,stx
-             [(pat) #,(syntax/loc stx (match-let* (rest-pats ...)
-					 body1 body ...))])]))
-
-     (define-syntax (match-let-values stx)
-       (syntax-parse stx
-         [(_ (~and clauses ([(patses ...) rhses:expr] ...)) body1 body ...)
-          (define-values (let-clauses match-clauses)
-            (for/lists (let-clauses match-clauses)
-                ([pats (syntax->list #'((patses ...) ...))]
-                 [rhs (syntax->list #'(rhses ...))])
-              (with-syntax ([(pats ...) pats]
-                            [(ids ...) (generate-temporaries pats)])
-                (values #`[(ids ...) #,rhs]
-                        #`([pats ids] ...)))))
-          #`(let-values #,let-clauses
-              #,(quasisyntax/loc stx
-                  (match-let #,(append-map syntax->list match-clauses)
-                    (let () body1 body ...))))]))
-
-     (define-syntax (match-let*-values stx)
-       (syntax-parse stx
-         [(_ () body1 body ...)
-          #'(let () body1 body ...)]
-         [(_ ([pats rhs] rest-pats ...) body1 body ...)
-          #`(match-let-values ([pats rhs])
-              #,(syntax/loc stx (match-let*-values (rest-pats ...)
-                                   body1 body ...)))]))
 
+     (define-syntax-rule (match-let* ([pat exp] ...) body1 body ...)
+       (match-let*-values ([(pat) exp] ...) body1 body ...))
 
      (define-syntax (match-letrec stx)
        (syntax-parse stx
@@ -149,6 +171,6 @@
               (define-values vars
                 (let-values ([(ids ...) rhs])
                   (apply values
-                       (append
+                         (append
-                        (match*/derived (ids) #,stx
+                          (match*/derived (ids) #,stx
-                                        [(pats) (list . pat-vars)]) ...))))))])))))
+                                          [(pats) (list . pat-vars)]) ...))))))])))))

collects/racket/match/legacy-match.rkt

@@ -18,4 +18,4 @@
 (define-forms parse/legacy
   match match* match-lambda match-lambda* match-lambda** match-let match-let*
   match-let-values match-let*-values
-  match-define match-define-values match-letrec match/derived match*/derived)
+  match-define match-define-values match-letrec match/values match/derived match*/derived)

collects/racket/match/match.rkt

@@ -20,4 +20,4 @@
 (define-forms parse
   match match* match-lambda match-lambda* match-lambda** match-let match-let*
   match-let-values match-let*-values
-  match-define match-define-values match-letrec match/derived match*/derived)
+  match-define match-define-values match-letrec match/values match/derived match*/derived)

collects/scribblings/reference/match.scrbl

@@ -368,6 +368,13 @@ same number of patterns as the number of @racket[val-expr]s.
 ]
 }
 
+@defform[(match/values expr clause clause ...)]{
+If @racket[expr] evaluates to @racket[n] values, then match all @racket[n]
+values against the patterns in @racket[clause ...]. Each clause must contain
+exactly @racket[n] patterns. At least one clause is required to determine how
+many values to expect from @racket[expr].
+}
+
 @defform[(match-lambda clause ...)]{
 
 Equivalent to @racket[(lambda (id) (match id clause ...))].

collects/tests/match/examples.rkt

@@ -672,4 +672,24 @@
              [(foo) 0]
              [_ 1])))
 
+   (comp '(1 2 4)
+         (call-with-values
+           (λ () (match-let-values ([(x y) (values 1 2)] [(3 w) (values 3 4)])
+                   (list x y w)))
+           list))
+
+   (comp '(1 3 4)
+         (call-with-values
+           (λ () (match-let*-values ([(x y) (values 1 2)] [(y w) (values 3 4)])
+                   (list x y w)))
+           list))
+
+   (comp '(1 2 3)
+         (match/values (values 1 2 3)
+           [(x y z) (list x y z)]))
+
+   (comp '(1 2)
+         (let () (match-define-values (x y 3) (values 1 2 3))
+              (list x y)))
+
 ))