.

original commit: 28e8d7d337f009adcb92d142d6f92140379d506d

collects/mzlib/contract.ss

@@ -1231,10 +1231,14 @@ add struct contracts for immutable structs?
                          [(field-var ...) (generate-temporaries flds)]
                          [(field/app-var ...) (generate-temporaries flds)])
              (syntax
-              (let ([method-ctc-var method-ctc-stx] ...
+              (let ([method-ctc-var method-ctc-stx] 
-                                                    [field-ctc-var (coerce-contract object-contract field-ctc-stx)] ...)
+                    ...
-                (let ([method-var (contract-proc method-ctc-var)] ...
+                    [field-ctc-var (coerce-contract object-contract field-ctc-stx)]
-                                                                  [field-var (contract-proc field-ctc-var)] ...)
+                    ...)
+                (let ([method-var (contract-proc method-ctc-var)] 
+                      ...
+                      [field-var (contract-proc field-ctc-var)] 
+                      ...)
                   (make-contract
                    `(object-contract 
                      ,(build-compound-type-name 'method-name method-ctc-var) ...
@@ -2432,6 +2436,8 @@ add struct contracts for immutable structs?
            vectorof vector-immutableof vector/c vector-immutable/c 
            cons-immutable/c cons/c list-immutable/c list/c
            box-immutable/c box/c
+           promise/c
+           struct/c
 	   mixin-contract make-mixin-contract
            syntax/c)
   
@@ -2964,6 +2970,72 @@ add struct contracts for immutable structs?
          (and (syntax? val)
               (pred (syntax-e val)))))))
   
+  (define promise/c
+    (lambda (ctc-in)
+      (let* ([ctc (coerce-contract promise/c ctc-in)]
+             [ctc-proc (contract-proc ctc)])
+        (make-contract
+         (build-compound-type-name 'promise/c ctc)
+         (lambda (pos neg src-info orig-str)
+           (let ([p-app (ctc-proc pos neg src-info orig-str)])
+             (lambda (val)
+               (unless (promise? val)
+                 (raise-contract-error
+                  src-info
+                  pos
+                  neg
+                  orig-str
+                  "expected <promise>, given: ~e"
+                  val))
+               (delay (p-app (force val))))))))))
+  
+  (define-syntax (struct/c stx)
+    (syntax-case stx ()
+      [(_ struct-name args ...)
+       (and (identifier? (syntax struct-name))
+            (syntax-local-value (syntax struct-name) (lambda () #f)))
+       (with-syntax ([(ctc-x ...) (generate-temporaries (syntax (args ...)))]
+                     [(ctc-proc-x ...) (generate-temporaries (syntax (args ...)))]
+                     [(ctc-app-x ...) (generate-temporaries (syntax (args ...)))]
+                     [(type-desc-id 
+                       constructor-id 
+                       predicate-id 
+                       (selector-id ...)
+                       (mutator-id ...)
+                       super-id)
+                      (syntax-local-value (syntax struct-name))])
+         (syntax
+          (let ([ctc-x (coerce-contract struct/c args)] ...)
+            
+            (unless predicate-id
+              (error 'struct/c "could not determine predicate for ~s" 'struct-name))
+            (unless (and selector-id ...)
+              (error 'struct/c "could not determine selectors for ~s" 'struct-name))
+            
+            (unless (flat-contract? ctc-x)
+              (error 'struct/c "expected flat contracts as arguments, got ~e" ctc-x))
+            ...
+            
+            (let ([ctc-proc-x (contract-proc ctc-x)] ...)
+              (make-contract
+               (build-compound-type-name 'struct/c 'struct-name ctc-x ...)
+               (lambda (pos neg src-info orig-str)
+                 (let ([ctc-app-x (ctc-proc-x pos neg src-info orig-str)] ...)
+                   (lambda (val)
+                     (unless (predicate-id val)
+                       (raise-contract-error
+                        src-info
+                        pos
+                        neg
+                        orig-str
+                        "expected <~a>, given: ~e"
+                        'struct-name
+                        val))
+                    (ctc-app-x (selector-id val)) ...
+                     val))))))))]
+      [(_ struct-name anything ...)
+       (raise-syntax-error 'struct/c "expected a struct identifier" stx (syntax struct-name))]))
+  
   (define (flat-contract/predicate? pred)
     (or (flat-contract? pred)
         (and (procedure? pred)

collects/tests/mzscheme/contract-test.ss

@@ -2395,6 +2395,79 @@
                'neg)
      1))
   
+  (test/pos-blame
+   'promise/c1
+   '(force (contract (promise/c boolean?)
+                     (delay 1)
+                     'pos
+                     'neg)))
+  
+  (test/spec-passed
+   'promise/c2
+   '(force (contract (promise/c boolean?)
+                     (delay #t)
+                     'pos
+                     'neg)))
+  
+  (test/spec-passed/result
+   'promise/c3
+   '(let ([x 0])
+      (contract (promise/c any/c)
+                (delay (set! x (+ x 1)))
+                'pos
+                'neg)
+      x)
+   0)
+  
+  (test/spec-passed/result
+   'promise/c4
+   '(let ([x 0])
+      (force (contract (promise/c any/c)
+                       (delay (set! x (+ x 1)))
+                       'pos
+                       'neg))
+      x)
+   1)
+  
+  (test/spec-passed/result
+   'promise/c5
+   '(let ([x 0])
+      (let ([p (contract (promise/c any/c)
+                         (delay (set! x (+ x 1)))
+                         'pos
+                         'neg)])
+        (force p)
+        (force p))
+      x)
+   1)
+  
+  (test/spec-passed
+   'struct/c1
+   '(let ()
+      (define-struct s (a))
+      (contract (struct/c s integer?)
+                (make-s 1)
+                'pos
+                'neg)))
+  
+  (test/pos-blame
+   'struct/c2
+   '(let ()
+      (define-struct s (a))
+      (contract (struct/c s integer?)
+                (make-s #f)
+                'pos
+                'neg)))
+  
+  (test/pos-blame
+   'struct/c3
+   '(let ()
+      (define-struct s (a))
+      (contract (struct/c s integer?)
+                1
+                'pos
+                'neg)))
+  
   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   ;;                                                        ;;
   ;;   Flat Contract Tests                                  ;;
@@ -2640,7 +2713,8 @@
              (object-contract (m (-> integer? any))))
   (test-name '(object-contract (m (-> integer? (values integer? integer?)))) 
              (object-contract (m (-> integer? (values integer? integer?)))))
-  (test-name '(object-contract (m (case-> (-> integer? integer? integer?) (-> integer? (values integer? integer?)))))
+  (test-name '(object-contract (m (case-> (-> integer? integer? integer?)
+                                          (-> integer? (values integer? integer?)))))
              (object-contract (m (case-> 
                                   (-> integer? integer? integer?)
                                   (-> integer? (values integer? integer?))))))
@@ -2669,6 +2743,10 @@
              (object-contract (m (->r ((x number?) (y boolean?) (z pair?)) number?))))
   (test-name '(object-contract (m (->r ((x ...) (y ...) (z ...)) rest-x ... ...))) 
              (object-contract (m (->r ((x number?) (y boolean?) (z pair?)) rest-x any/c number?))))
-  
+  (test-name '(promise/c any/c) (promise/c any/c))
+  (test-name '(struct/c st integer?) 
+             (let ()
+               (define-struct st (a))
+               (struct/c st integer?)))
   ))
 (report-errs)