Add more missing properties.

pkgs/racket-test/tests/racket/contract/arrow-d.rkt

@@ -17,7 +17,19 @@
   (test/spec-passed
    '->d1
    '((contract (->d () () [x number?]) (lambda () 1) 'pos 'neg)))
-  
+
+  (test/spec-passed/result
+   '->d1a
+   '(and (value-contract (contract (->d () () [x number?]) (lambda () 1) 'pos 'neg))
+         #t)
+   #t)
+
+  (test/spec-passed/result
+   '->d1b
+   '(and (value-blame (contract (->d () () [x number?]) (lambda () 1) 'pos 'neg))
+         #t)
+   #t)
+
   (test/spec-passed
    '->d2
    '((contract (->d ([x number?]) () (values [r number?])) (lambda (x) (+ x 1)) 'pos 'neg) 1))

pkgs/racket-test/tests/racket/contract/arrow.rkt

@@ -250,6 +250,12 @@
                   integer?)
               (lambda (x1 x2 x3 x4 x5 x6 x7 x8 x9 x10) x1) 'pos 'neg))
   
+  (test/spec-passed/result
+   'contract-arrow1c
+   '(and (value-contract (contract (integer? . -> . integer?) (lambda (x) x) 'pos 'neg))
+         #t)
+   #t)
+
   (test/pos-blame
    'contract-arrow2
    '(contract (integer? . -> . integer?) (lambda (x y) x) 'pos 'neg))
@@ -286,6 +292,12 @@
   (test/neg-blame
    'contract-arrow-any3
    '((contract (integer? . -> . any) (lambda (x) #f) 'pos 'neg) #t))
+
+  (test/spec-passed/result
+   'contract-arrow-any4
+   '(and (value-contract (contract (-> integer? any) (lambda (x) x) 'pos 'neg))
+         #t)
+   #t)
   
   (test/spec-passed
    'contract-arrow-all-anys1
@@ -484,6 +496,11 @@
                 (struct s ())
                 ((impersonate-procedure s? (λ (x) (values (λ (r) "") x))) 11))
               'pos 'neg))
+  (test/spec-passed/result
+   'predicate/c15
+   '(and (value-contract (contract predicate/c boolean? 'pos 'neg))
+         #t)
+   #t)
 
   (test/spec-passed/result
    '->void.1

pkgs/racket-test/tests/racket/contract/evt.rkt

@@ -11,6 +11,12 @@
    'evt/c-first-order-2
    '(contract (evt/c) always-evt 'pos 'neg))
 
+  (test/spec-passed/result
+   'evt/c-first-order-3
+   '(and (value-contract (contract (evt/c) always-evt 'pos 'neg))
+         #t)
+   #t)
+
   (test/pos-blame
    'evt/c-higher-order-1
    '(let ([evt (contract (evt/c symbol?)

pkgs/racket-test/tests/racket/contract/struct-dc.rkt

@@ -15,6 +15,28 @@
                 'pos
                 'neg)))
   
+  (test/spec-passed/result
+   'struct/c1a
+   '(let ()
+      (define-struct s (a))
+      (and (value-contract (contract (struct/c s (or/c number? (-> void?))) ; want non-flat
+                                     (make-s 1)
+                                     'pos
+                                     'neg))
+           #t))
+   #t)
+  
+  (test/spec-passed/result
+   'struct/c1b
+   '(let ()
+      (define-struct s (a))
+      (and (value-blame (contract (struct/c s (or/c number? (-> void?))) ; want non-flat
+                                  (make-s 1)
+                                  'pos
+                                  'neg))
+           #t))
+   #t)
+  
   (test/pos-blame
    'struct/c2
    '(let ()
@@ -240,6 +262,32 @@
                 (s 1 #f)
                 'pos
                 'neg)))
+
+  (test/spec-passed/result
+   'struct/dc-1a
+   '(let ()
+      (struct s (a b))
+      (and (value-contract (contract (struct/dc s
+                                                [a () (or/c number? (-> void?))] ; want non-flat
+                                                [b (a) boolean?])
+                                     (s 1 #f)
+                                     'pos
+                                     'neg))
+           #t))
+   #t)
+
+  (test/spec-passed/result
+   'struct/dc-1b
+   '(let ()
+      (struct s (a b))
+      (and (value-blame (contract (struct/dc s
+                                             [a () (or/c number? (-> void?))] ; want non-flat
+                                             [b (a) boolean?])
+                                  (s 1 #f)
+                                  'pos
+                                  'neg))
+           #t))
+   #t)
   
   (test/spec-passed
    'struct/dc-1a

pkgs/racket-test/tests/racket/contract/unconstrained-domain.rkt

@@ -68,4 +68,21 @@
   (test/pos-blame
    'unconstrained-domain->11
    '((contract (unconstrained-domain-> number? number?) (λ () 1) 'pos 'neg)))
+
+  (test/spec-passed/result
+   'unconstrained-domain->12
+   '(and (value-contract (contract (unconstrained-domain-> number?)
+                                   (lambda (x) 1)
+                                   'pos
+                                   'neg))
+         #t)
+   #t)
+  (test/spec-passed/result
+   'unconstrained-domain->13
+   '(and (value-blame (contract (unconstrained-domain-> number?)
+                                (lambda (x) 1)
+                                'pos
+                                'neg))
+         #t)
+   #t)
   )

racket/collects/racket/contract/private/arr-d.rkt

@@ -412,7 +412,8 @@
                                                   dom-blame neg-party)
                                   (loop (cdr args)
                                         (cdr non-kwd-ctcs)))]))))))))
-         impersonator-prop:contracted ->d-stct)))))
+         impersonator-prop:contracted ->d-stct
+         impersonator-prop:blame (blame-add-missing-party blame neg-party))))))
 
 (define (build-values-string desc dep-pre-args)
   (cond

racket/collects/racket/contract/private/misc.rkt

@@ -766,7 +766,10 @@
          '(expected: "~s" given: "~e")
          (contract-name evt-ctc)
          val))
-      (chaperone-evt val (generator (cons blame neg-party))))))
+      (chaperone-evt val
+                     (generator (cons blame neg-party))
+                     impersonator-prop:contracted evt-ctc
+                     impersonator-prop:blame (blame-add-missing-party blame neg-party)))))
 
 ;; evt/c-first-order : Contract -> Any -> Boolean
 ;; First order check for evt/c

racket/collects/racket/contract/private/opters.rkt

@@ -464,9 +464,11 @@
                        (if (and (equal? (procedure-arity val) 1)
                                 (let-values ([(a b) (procedure-keywords val)])
                                   (null? b)))
-                           (chaperone-procedure val exact-proc)
+                           (chaperone-procedure val exact-proc
+                                                impersonator-prop:contracted ctc
+                                                impersonator-prop:blame blame)
                            (if (procedure-arity-includes? val 1)
-                               (handle-non-exact-procedure val 1 blame exact-proc)
+                               (handle-non-exact-procedure val 1 blame exact-proc ctc)
                                (raise-flat-arrow-err blame val 1))))
                      (raise-flat-arrow-err blame val 1)))))
    #:lifts null
@@ -567,6 +569,7 @@
                               (cons (optres-name optres-rng) rng-names))]))])
       (values
        (with-syntax ((val (opt/info-val opt/info))
+                     (ctc (opt/info-contract opt/info))
                      (blame (opt/info-blame opt/info))
                      ((dom-arg ...) dom-vars)
                      ((rng-arg ...) rng-vars)
@@ -608,8 +611,9 @@
                  (chaperone-procedure val exact-proc
                                       impersonator-prop:application-mark 
                                       (cons opt->/c-cm-key cont-mark-value)
+                                      impersonator-prop:contracted ctc
                                       impersonator-prop:blame blame)
-                 (handle-non-exact-procedure val dom-len blame exact-proc))))
+                 (handle-non-exact-procedure val dom-len blame exact-proc ctc))))
        (append lifts-doms lifts-rngs)
        (append superlifts-doms superlifts-rngs)
        (append partials-doms partials-rngs)
@@ -668,6 +672,7 @@
       (values
        (with-syntax ((blame (opt/info-blame opt/info))
                      (val (opt/info-val opt/info))
+                     (ctc (opt/info-contract opt/info))
                      ((dom-arg ...) dom-vars)
                      ((next-dom ...) next-doms)
                      (dom-len (length dom-vars)))
@@ -680,6 +685,7 @@
                   [(dom-arg ...)  (values next-dom ...)]
                   [args
                    (bad-number-of-arguments blame val args dom-len)])
+                impersonator-prop:contracted ctc
                 impersonator-prop:blame blame)))
          (if all-anys?
              #`(if (procedure-arity-exactly/no-kwds val #,(length doms))
@@ -739,7 +745,7 @@
 
 (define/opter (predicate/c opt/i opt/info stx) (predicate/c-optres opt/info #t))
 
-(define (handle-non-exact-procedure val dom-len blame exact-proc)
+(define (handle-non-exact-procedure val dom-len blame exact-proc ctc)
   (check-procedure val #f dom-len 0 '() '() blame #f)
   (chaperone-procedure
    val
@@ -755,7 +761,9 @@
                                    (cond
                                      [(null? (cdr kwds)) '()]
                                      [else (cons " " (loop (cdr kwds)))]))))))
-    exact-proc)))
+    exact-proc)
+   impersonator-prop:contracted ctc
+   impersonator-prop:blame blame))
 
 (define (raise-flat-arrow-err blame val n)
   (raise-blame-error blame val

racket/collects/racket/contract/private/struct-dc.rkt

@@ -314,7 +314,11 @@
                     [dep-args '()])
            (cond
              [(null? subcontracts)
-              (define (app* f v l) (if (null? l) v (apply f v l)))
+              (define (app* f v l)
+                (if (null? l)
+                    v
+                    (apply f v (append l (list impersonator-prop:contracted ctc
+                                               impersonator-prop:blame (blame-add-missing-party blame neg-party))))))
               (app* chaperone-struct
                     (app* impersonate-struct
                           v
@@ -1439,7 +1443,9 @@
                                #,(opt/info-val opt/info)
                                #,@(reverse s-chap-code) ;; built the last backwards, so reverse it here
                                stronger-prop-desc
-                               (vector free-var ...)))
+                               (vector free-var ...)
+                               impersonator-prop:contracted #,(opt/info-contract opt/info)
+                               impersonator-prop:blame #,(opt/info-blame opt/info)))
                             (struct/dc-error #,(opt/info-blame opt/info) #,(opt/info-val opt/info) 'struct-name)))))
              #:lifts
              s-lifts

racket/collects/racket/contract/private/unconstrained-domain-arrow.rkt

@@ -88,6 +88,7 @@
                   neg-party
                   projs)
            impersonator-prop:contracted ctc
+           impersonator-prop:blame (blame-add-missing-party orig-blame neg-party)
            impersonator-prop:application-mark
            (cons tail-contract-key (list* neg-party blame-party-info range-contracts)))))))