..

original commit: af853d3f74cd131ef89f650b7a190e8be711f59f

collects/mzlib/contract.ss

@@ -2072,6 +2072,7 @@ add structu contracts for immutable structs?
   (provide any?
            anaphoric-contracts
            flat-rec-contract
+           flat-murec-contract
 	   union
            and/c
 	   not/f
@@ -2110,8 +2111,40 @@ add structu contracts for immutable structs?
               name))))]
       [(_ name ctc ...)
        (raise-syntax-error 'flat-rec-contract "expected first argument to be an identifier" stx (syntax name))]))
-  
 
+  (define-syntax (flat-murec-contract stx)
+    (syntax-case stx  ()
+      [(_ ([name ctc ...] ...) body1 body ...)
+       (andmap identifier? (syntax->list (syntax (name ...))))
+       (with-syntax ([((ctc-id ...) ...) (map generate-temporaries
+                                              (syntax->list (syntax ((ctc ...) ...))))]
+                     [(pred-id ...) (generate-temporaries (syntax (name ...)))]
+                     [((pred-arm-id ...) ...) (map generate-temporaries
+                                               (syntax->list (syntax ((ctc ...) ...))))])
+         (syntax 
+          (let* ([pred-id (lambda (x) (error 'flat-murec-contract "applied too soon"))] ...
+                 [name (flat-contract (let ([name (lambda (x) (pred-id x))]) name))] ...)
+            (let-values ([(ctc-id ...) (values (coerce-contract flat-rec-contract ctc) ...)] ...)
+              (begin
+                (void)
+                (unless (flat-contract? ctc-id)
+                  (error 'flat-rec-contract "expected flat contracts as arguments, got ~e" ctc-id))
+                ...) ...
+              (set! pred-id
+                    (let ([pred-arm-id (flat-contract-predicate ctc-id)] ...)
+                      (lambda (x)
+                        (or (pred-arm-id x) ...)))) ...
+              body1
+              body ...))))]
+      [(_ ([name ctc ...] ...) body1 body ...)
+       (for-each (lambda (name)
+                   (unless (identifier? name)
+                     (raise-syntax-error 'flat-rec-contract
+                                         "expected an identifier" stx name))))]
+      [(_ ([name ctc ...] ...))
+       (raise-syntax-error 'flat-rec-contract "expected at least one body expression" stx)]))
+      
+  
   (define anaphoric-contracts
     (case-lambda
       [() (make-anaphoric-contracts (make-hash-table 'weak))]

collects/tests/mzscheme/contract-test.ss

@@ -1938,6 +1938,11 @@
   (test-flat-contract '(box/p (flat-contract boolean?)) (box #t) #f)
   
   (test-flat-contract '(flat-rec-contract sexp (cons/p sexp sexp) number?) '(1 2 . 3) '(1 . #f))
+  (test-flat-contract '(flat-murec-contract ([even1 (union null? (cons/p number? even2))] 
+                                             [even2 (cons/p number? even1)])
+                                            even1)
+                      '(1 2 3 4)
+                      '(1 2 3))
   
   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   ;;                                                        ;;