.

original commit: 405cb4839a3bc22112b9f96d29b0f1be52327799

collects/mzlib/contract.ss

@@ -8,11 +8,16 @@ add struct contracts for immutable structs?
 |#
 
 (module contract mzscheme
+  
+  ;; no bytes in v206
+;  (define (bytes? x) #f)
+  
   (provide (rename -contract contract)
            ->
            ->d
            ->*
            ->d*
+           ->r
            case->
 	   opt->
            opt->*
@@ -646,6 +651,50 @@ add struct contracts for immutable structs?
 ;                                                                                   
 ;                                                                                   
 
+  (define-syntax (->r stx)
+    (syntax-case stx ()
+      [(-> ([x dom] ...) rng)
+       (and (andmap identifier? (syntax->list (syntax (x ...))))
+            (not (check-duplicate-identifier (syntax->list (syntax (x ...))))))
+       (with-syntax ([(dom-id ...) (generate-temporaries (syntax (x ...)))]
+                     [arity-count (length (syntax->list (syntax (x ...))))])
+         (syntax 
+          (make-contract 
+           "name"
+           (lambda (pos-blame neg-blame src-info orig-str)
+             (lambda (v)
+               (unless (procedure? v)
+                 (raise-contract-error src-info
+                                       pos-blame
+                                       neg-blame
+                                       orig-str
+                                       "expected a procedure, got ~e"
+                                       v))
+               (unless (procedure-arity-includes? v arity-count)
+                 (raise-contract-error src-info
+                                       pos-blame
+                                       neg-blame
+                                       orig-str
+                                       "expected a procedure of arity ~a, got ~e"
+                                       arity-count
+                                       v))
+               (lambda (x ...)
+                 (let ([dom-id ((coerce/select-contract ->r dom) pos-blame neg-blame src-info orig-str)]
+                       ...
+                       [rng-id ((coerce/select-contract ->r rng) pos-blame neg-blame src-info orig-str)])
+                   (rng-id (v (dom-id x) ...)))))))))]
+      [(-> ([x dom] ...) rng)
+       (andmap identifier? (syntax->list (syntax (x ...))))
+       (raise-syntax-error 
+        '->r
+        "duplicate identifier"
+        stx
+        (check-duplicate-identifier (syntax->list (syntax (x ...)))))]
+      [(-> ([x dom] ...) rng)
+       (for-each (lambda (x) (unless (identifier? x) (raise-syntax-error '->r "expected identifier" stx x)))
+                 (syntax->list (syntax (x ...))))]
+      [(-> x dom rng)
+       (raise-syntax-error '->r "expected list of identifiers and expression pairs" stx (syntax x))]))
   
   (define-syntax-set (-> ->* ->d ->d* case-> object-contract opt-> opt->*)
     

collects/tests/mzscheme/contract-test.ss

@@ -597,6 +597,46 @@
                  'neg)
        (lambda () (set! x 2)))))
   
+  (test/spec-passed
+   '->r1
+   '((contract (->r () number?) (lambda () 1) 'pos 'neg)))
+  
+  (test/spec-passed
+   '->r2
+   '((contract (->r ([x number?]) number?) (lambda (x) (+ x 1)) 'pos 'neg) 1))
+
+  (test/pos-blame
+   '->r3
+   '((contract (->r () number?) 1 'pos 'neg)))
+  
+  (test/pos-blame
+   '->r4
+   '((contract (->r () number?) (lambda (x) x) 'pos 'neg)))
+  
+  (test/neg-blame
+   '->r5
+   '((contract (->r ([x number?]) (<=/c x)) (lambda (x) (+ x 1)) 'pos 'neg) #f))
+  
+  (test/pos-blame
+   '->r6
+   '((contract (->r ([x number?]) (<=/c x)) (lambda (x) (+ x 1)) 'pos 'neg) 1))
+  
+  (test/spec-passed
+   '->r7
+   '((contract (->r ([x number?][y (<=/c x)]) (<=/c x)) (lambda (x y) (- x 1)) 'pos 'neg) 1 0))
+  
+  (test/neg-blame
+   '->r8
+   '((contract (->r ([x number?][y (<=/c x)]) (<=/c x)) (lambda (x y) (+ x 1)) 'pos 'neg) 1 2))
+  
+  (test/spec-passed
+   '->r9
+   '((contract (->r ([y (<=/c x)][x number?]) (<=/c x)) (lambda (y x) (- x 1)) 'pos 'neg) 1 2))
+  
+  (test/neg-blame
+   '->r10
+   '((contract (->r ([y (<=/c x)][x number?]) (<=/c x)) (lambda (y x) (+ x 1)) 'pos 'neg) 1 0))
+  
   #;
   (test/neg-blame
    'combo1