From 1277f0347ab026de0182774f8a47dadf88d522f9 Mon Sep 17 00:00:00 2001
From: Vincent St-Amour <stamourv@racket-lang.org>
Date: Mon, 11 Jan 2016 16:22:11 -0600
Subject: [PATCH] Instrumentation for object-contract.

---
 .../tests/racket/contract/prof.rkt            | 30 ++++++++++++++-----
 .../collects/racket/private/class-c-old.rkt   | 11 ++++++-
 2 files changed, 32 insertions(+), 9 deletions(-)

diff --git a/pkgs/racket-test/tests/racket/contract/prof.rkt b/pkgs/racket-test/tests/racket/contract/prof.rkt
index 2977ba24cb..77f60f59d0 100644
--- a/pkgs/racket-test/tests/racket/contract/prof.rkt
+++ b/pkgs/racket-test/tests/racket/contract/prof.rkt
@@ -335,25 +335,39 @@
          (mark-value '(chocolate-bar)))))
    '(chocolate-bar truffle fudge ganache))
 
-  (test/spec-passed/result
+  (test/spec-passed
    'contract-marks37
    '(let ()
       (define/contract my-evt
         (evt/c (λ _ (named-blame? 'top-level)))
         always-evt)
-      (sync my-evt)
-      3)
-   3)
+      (sync my-evt)))
 
-  (test/spec-passed/result
+  (test/spec-passed
    'contract-marks38
    '(let ()
       (define/contract chan
         (channel/c (λ _ (named-blame? 'top-level)))
         (make-channel))
       (thread (λ () (channel-get chan)))
-      (channel-put chan 'not-a-string)
-      3)
-   3)
+      (channel-put chan 'not-a-string)))
+
+  (test/spec-passed
+   'contract-marks39
+   '(let ()
+      (eval '(require racket/class))
+      (eval '((contract (->m neg-blame? any/c) (λ (_ x) x) 'pos 'neg) 'a 1))))
+
+  (test/spec-passed
+   'contract-marks40
+   '(let ()
+      (define o
+        (contract
+         (object-contract (field x pos-blame?) (f (->m neg-blame?)))
+         (new (class object% (init-field x) (define/public (f) x) (super-new)) [x 3])
+         'pos 'neg))
+      (get-field x o)
+      (set-field! x o 2)
+      (send o f)))
 
   )
diff --git a/racket/collects/racket/private/class-c-old.rkt b/racket/collects/racket/private/class-c-old.rkt
index 22e31cf62d..0618e0c02e 100644
--- a/racket/collects/racket/private/class-c-old.rkt
+++ b/racket/collects/racket/private/class-c-old.rkt
@@ -1649,6 +1649,15 @@
           (define prj (contract-late-neg-projection c))
           (define p-pos (prj (blame-add-field-context blame f #:swap? #f)))
           (define p-neg (prj (blame-add-field-context blame f #:swap? #t)))
-          (hash-set! field-ht f (field-info-extend-external fi p-pos p-neg neg-party)))))
+          (hash-set! field-ht f (field-info-extend-external fi
+                                                            (lambda args
+                                                              (with-contract-continuation-mark
+                                                               (cons blame neg-party)
+                                                               (apply p-pos args)))
+                                                            (lambda args
+                                                              (with-contract-continuation-mark
+                                                               (cons blame neg-party)
+                                                               (apply p-neg args)))
+                                                            neg-party)))))
     
     (copy-seals cls c)))