improve value-contract handling a little bit

That is, use pairs on the property in more places, as the pair
already was computed and the value-blame function already does
the needful when it sees a pair on the property.

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

@@ -216,7 +216,8 @@
   (rewrite-test rewrite-to-add-opt/c   "rewrite-to-add-opt/c")
   (rewrite-test rewrite-to-multi-wrap "rewrite-to-double-wrap"))
 
-(define (test/spec-passed/result name expression result [double-wrapped-result result])
+(define (test/spec-passed/result name expression result [double-wrapped-result result]
+                                 #:skip-opt/c? [skip-opt/c? #f])
   (parameterize ([compile-enforce-module-constants #f])
     (contract-eval #:test-case-name name `(,test #:test-case-name ',name ',result eval ',expression))
     (define (rewrite-test wrapper wrapper-name [result* result])
@@ -229,7 +230,7 @@
            ',result*
            eval
            ',(wrapper expression k)))))
-    (rewrite-test rewrite-to-add-opt/c   "rewrite-to-add-opt/c")
+    (unless skip-opt/c? (rewrite-test rewrite-to-add-opt/c   "rewrite-to-add-opt/c"))
     (unless (eq? double-wrapped-result do-not-double-wrap)
       (rewrite-test rewrite-to-multi-wrap "rewrite-to-double-wrap" double-wrapped-result))
 

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

@@ -65,9 +65,7 @@
         (contract (-> integer? integer?) (λ (x) x) 'pos 'neg))
       ;; opt/c version doesn't yet have blame, so
       ;; we require only that when there is blame, that the blame is right.
-      (or (and (has-blame? f)
-               (blame-positive (value-blame f)))
-          'pos))
+      (blame-positive (value-blame f)))
    'pos)
 
   (test/spec-passed/result
@@ -75,11 +73,7 @@
    '(let ()
       (define f
         (contract (-> integer? integer?) (λ (x) x) 'pos 'neg))
-      ;; opt/c version doesn't yet have blame, so
-      ;; we require only that when there is blame, that the blame is right.
-      (or (and (has-blame? f)
-               (blame-negative (value-blame f)))
-          'neg))
+      (blame-negative (value-blame f)))
    'neg)
 
   (test/spec-passed/result
@@ -87,11 +81,7 @@
    '(let ()
       (define f
         (contract (set/c (-> integer? integer?) #:kind 'mutable) (mutable-set) 'pos 'neg))
-      ;; opt/c version doesn't yet have blame, so
-      ;; we require only that when there is blame, that the blame is right.
-      (or (and (has-blame? f)
-               (blame-positive (value-blame f)))
-          'pos))
+      (blame-positive (value-blame f)))
    'pos)
 
   (test/spec-passed/result
@@ -99,9 +89,34 @@
    '(let ()
       (define f
         (contract (set/c (-> integer? integer?) #:kind 'mutable) (mutable-set) 'pos 'neg))
-      ;; opt/c version doesn't yet have blame, so
-      ;; we require only that when there is blame, that the blame is right.
-      (or (and (has-blame? f)
-               (blame-negative (value-blame f)))
-          'neg))
-   'neg))
+      (blame-negative (value-blame f)))
+   'neg)
+
+  (test/spec-passed/result
+   'value-blame.5
+   '(let ()
+      (define f
+        (contract (->i () any) (λ () 1) 'pos 'neg))
+      (list (blame-negative (value-blame f))
+            (blame-positive (value-blame f))))
+   '(neg pos))
+
+  (test/spec-passed/result
+   'value-blame.6
+   '(let ()
+      (define f
+        (contract (box/c (-> integer? integer?)) (box (λ (x) 1)) 'pos 'neg))
+      (list (blame-negative (value-blame f))
+            (blame-positive (value-blame f))))
+   '(neg pos))
+
+  (test/spec-passed/result
+   'value-blame.7
+   '(let ()
+      (struct s (a b))
+      (define an-s
+        (contract (struct/c s integer? (-> integer? any)) (s 1 void) 'pos 'neg))
+      (list (blame-negative (value-blame an-s))
+            (blame-positive (value-blame an-s))))
+   '(neg pos))
+  )

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

@@ -985,7 +985,7 @@ evaluted left-to-right.)
                   blame+neg-party
                   (apply arg-checker args)))))
             impersonator-prop:contracted ctc
-            impersonator-prop:blame (blame-add-missing-party blame neg-party)))))))
+            impersonator-prop:blame blame+neg-party))))))
 
 (define-for-syntax (arg/res-to-indy-var indy-arg-vars ordered-args indy-res-vars ordered-ress var)
   (define (try vars ordered)

racket/collects/racket/contract/private/box.rkt

@@ -187,7 +187,7 @@
                         blame+neg-party
                       (neg-elem-w-proj v neg-party)))
                   impersonator-prop:contracted ctc
-                  impersonator-prop:blame (blame-add-missing-party blame neg-party)))])))
+                  impersonator-prop:blame blame+neg-party))])))
       (cond
         [filled?
          (make-val-np/proc maybe-pos-elem-r-proj maybe-neg-elem-w-proj)]

racket/collects/racket/contract/private/case-arrow.rkt

@@ -176,14 +176,14 @@
        f
        checker
        impersonator-prop:contracted ctc
-       impersonator-prop:blame (blame-add-missing-party blame neg-party)
+       impersonator-prop:blame blame+neg-party
        impersonator-prop:application-mark
        (cons tail-contract-key (list* neg-party blame-party-info same-rngs)))
       (wrapper
        f
        checker
        impersonator-prop:contracted ctc
-       impersonator-prop:blame (blame-add-missing-party blame neg-party))))
+       impersonator-prop:blame blame+neg-party)))
 
 (define (raise-no-keywords-error f blame neg-party)
   (λ (kwds kwd-args . args)

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

@@ -450,7 +450,7 @@
                                      (format "\n   ~e" v))))])
                         promise))))
            impersonator-prop:contracted ctc
-           impersonator-prop:blame blame)
+           impersonator-prop:blame blame+neg-party)
           (raise-blame-error
            blame #:missing-party neg-party
            val
@@ -732,8 +732,7 @@
     (define ho-pos-projs (for/list ([proj (in-list ho-projs)]) (proj blame)))
     (define cc-neg-projs (for/list ([proj (in-list call/cc-projs)]) (proj swapped)))
     (define cc-pos-projs (for/list ([proj (in-list call/cc-projs)]) (proj blame)))
-    (define (make-proj projs neg-party)
-      (define blame+neg-party (cons blame neg-party))
+    (define (make-proj projs neg-party blame+neg-party)
       (λ vs
         (with-contract-continuation-mark
          blame+neg-party
@@ -742,25 +741,26 @@
                            [v (in-list vs)])
                   (proj v neg-party))))))
     (λ (val neg-party)
+      (define blame+neg-party (cons blame neg-party))
       ;; now do the actual wrapping
       (cond
         [(continuation-prompt-tag? val)
          ;; prompt/abort projections
-         (define proj1 (make-proj ho-pos-projs neg-party))
-         (define proj2 (make-proj ho-neg-projs neg-party))
+         (define proj1 (make-proj ho-pos-projs neg-party blame+neg-party))
+         (define proj2 (make-proj ho-neg-projs neg-party blame+neg-party))
          ;; call/cc projections
-         (define call/cc-guard (make-proj cc-pos-projs neg-party))
+         (define call/cc-guard (make-proj cc-pos-projs neg-party blame+neg-party))
          (define call/cc-proxy
            (λ (f)
              (proc-proxy
               f
               (λ args
-                (apply values (make-proj cc-neg-projs neg-party) args)))))
+                (apply values (make-proj cc-neg-projs neg-party blame+neg-party) args)))))
          (proxy val
                 proj1 proj2
                 call/cc-guard call/cc-proxy
                 impersonator-prop:contracted ctc
-                impersonator-prop:blame (blame-add-missing-party blame neg-party))]
+                impersonator-prop:blame blame+neg-party)]
         [else
          (raise-blame-error
           blame #:missing-party neg-party val
@@ -844,7 +844,7 @@
                         blame+neg-party
                         (proj2 v neg-party)))
                 impersonator-prop:contracted ctc
-                impersonator-prop:blame blame)]
+                impersonator-prop:blame blame+neg-party)]
         [else 
          (unless (contract-first-order-passes? ctc val)
            (raise-blame-error
@@ -933,10 +933,11 @@
          '(expected: "~s" given: "~e")
          (contract-name evt-ctc)
          val))
+      (define blame+neg-party (cons blame neg-party))
       (chaperone-evt val
-                     (generator (cons blame neg-party))
+                     (generator blame+neg-party)
                      impersonator-prop:contracted evt-ctc
-                     impersonator-prop:blame (blame-add-missing-party blame neg-party)))))
+                     impersonator-prop:blame blame+neg-party))))
 
 ;; evt/c-first-order : Contract -> Any -> Boolean
 ;; First order check for evt/c
@@ -1015,7 +1016,7 @@
                 (proj1 neg-party)
                 (proj2 neg-party)
                 impersonator-prop:contracted ctc
-                impersonator-prop:blame blame)]
+                impersonator-prop:blame (cons blame neg-party))]
         [else
          (raise-blame-error
           blame #:missing-party neg-party

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

@@ -319,7 +319,7 @@
                 (if (null? l)
                     v
                     (apply f v (append l (list impersonator-prop:contracted ctc
-                                               impersonator-prop:blame (blame-add-missing-party blame neg-party))))))
+                                               impersonator-prop:blame (cons blame neg-party))))))
               (app* chaperone-struct
                     (app* impersonate-struct
                           v