diff --git a/pkgs/errortrace-pkgs/errortrace-lib/errortrace/errortrace-lib.rkt b/pkgs/errortrace-pkgs/errortrace-lib/errortrace/errortrace-lib.rkt
index 44863a08ca..78c826d25e 100644
--- a/pkgs/errortrace-pkgs/errortrace-lib/errortrace/errortrace-lib.rkt
+++ b/pkgs/errortrace-pkgs/errortrace-lib/errortrace/errortrace-lib.rkt
@@ -433,8 +433,10 @@
 (define errortrace-annotate
   (lambda (top-e)
     (define (normal e)
-      (annotate-top (expand-syntax e) 
-                    (namespace-base-phase)))
+      (define expanded-e (expand-syntax e))
+      (parameterize ([original-stx e]
+                     [expanded-stx expanded-e])
+        (annotate-top expanded-e (namespace-base-phase))))
     (syntax-case top-e ()
       [(mod name . reste)
        (and (identifier? #'mod)
@@ -443,11 +445,11 @@
                                (namespace-base-phase)))
        (if (eq? (syntax-e #'name) 'errortrace-key)
            top-e
-           (let ([top-e (normal top-e)])
+           (let ([expanded-e (normal top-e)])
              (initialize-test-coverage)
              (add-test-coverage-init-code
               (transform-all-modules 
-               top-e
+               expanded-e
                (lambda (top-e mod-id)
                  (syntax-case top-e ()
                    [(mod name init-import mb)
diff --git a/pkgs/errortrace-pkgs/errortrace-lib/errortrace/stacktrace.rkt b/pkgs/errortrace-pkgs/errortrace-lib/errortrace/stacktrace.rkt
index 063c11a147..a85d9d2234 100644
--- a/pkgs/errortrace-pkgs/errortrace-lib/errortrace/stacktrace.rkt
+++ b/pkgs/errortrace-pkgs/errortrace-lib/errortrace/stacktrace.rkt
@@ -2,10 +2,14 @@
 (require racket/unit
          syntax/kerncase
          syntax/stx
+         syntax/source-syntax
          (for-template racket/base)
          (for-syntax racket/base)) ; for matching
 
-(provide stacktrace@ stacktrace^ stacktrace-imports^)
+(define original-stx (make-parameter #f))
+(define expanded-stx (make-parameter #f))
+
+(provide stacktrace@ stacktrace^ stacktrace-imports^ original-stx expanded-stx)
 (define-signature stacktrace-imports^
   (with-mark
    
@@ -19,6 +23,15 @@
    register-profile-start
    register-profile-done))
 
+;; The intentionally-undocumented format of bindings introduced by `make-st-mark` is:
+;; (cons syntax? (cons syntax? srcloc-list))
+
+;; The first syntax object is the original annotated source expression as a (shrunken)
+;; datum.
+
+;; The second syntax object is some part of the original syntax as a (shrunken)
+;; datum, which contains the code that expanded to the annotated expression.
+
 (define-signature stacktrace^
   (annotate-top
    annotate
@@ -55,14 +68,24 @@
       [(syntax? v) (short-version (syntax-e v) depth)]
       [else v]))
   
+  (define recover-table (make-hash))
+
   (define (make-st-mark stx phase)
     (unless (syntax? stx)
       (error 'make-st-mark
              "expected syntax object as argument, got ~e" stx))
     (cond
       [(syntax-source stx)
+       ;; this horrible indirection is needed because the errortrace
+       ;; unit is invoked only once but annotate-top might be called
+       ;; many times with diferent values for original-stx and
+       ;; expanded-stx
+       (define recover (hash-ref! recover-table (cons (original-stx) (expanded-stx))
+				  (lambda ()
+				    (recover-source-syntax (original-stx) (expanded-stx)))))
+       (define better-stx (and stx (recover stx)))
        (with-syntax ([quote (syntax-shift-phase-level #'quote phase)])
-         #`(quote (#,(short-version stx 10)
+         #`(quote (#,(short-version better-stx 10)
                    #,(syntax-source stx)
                    #,(syntax-line stx)
                    #,(syntax-column stx)
diff --git a/pkgs/errortrace-pkgs/errortrace-lib/info.rkt b/pkgs/errortrace-pkgs/errortrace-lib/info.rkt
index 877f35b89b..65f412fe32 100644
--- a/pkgs/errortrace-pkgs/errortrace-lib/info.rkt
+++ b/pkgs/errortrace-pkgs/errortrace-lib/info.rkt
@@ -1,6 +1,6 @@
 #lang info
 (define collection 'multi)
-(define deps '("base"))
+(define deps '("base" "source-syntax"))
 
 (define pkg-desc "implementation (no documentation) part of \"errortrace\"")
 
diff --git a/pkgs/plt-services/meta/props b/pkgs/plt-services/meta/props
index 816675ee86..f08355833d 100755
--- a/pkgs/plt-services/meta/props
+++ b/pkgs/plt-services/meta/props
@@ -1058,7 +1058,7 @@ path/s is either such a string or a list of them.
 "pkgs/plt-services/meta/props" responsible (eli jay) drdr:command-line (racket "-um" * "verify")
 "pkgs/plt-services/meta/web" drdr:command-line #f
 "pkgs/preprocessor" responsible (eli)
-"pkgs/profile-pkgs" responsible (eli)
+"pkgs/profile-pkgs" responsible (eli samth stamourv)
 "pkgs/profile-pkgs/profile-lib/profile/analyzer.rkt" drdr:command-line (raco "test" *)
 "pkgs/r5rs-pkgs" responsible (mflatt)
 "pkgs/r6rs-pkgs" responsible (mflatt)
diff --git a/pkgs/profile-pkgs/profile-doc/info.rkt b/pkgs/profile-pkgs/profile-doc/info.rkt
index 0e2c38b2a5..0ecfc386ec 100644
--- a/pkgs/profile-pkgs/profile-doc/info.rkt
+++ b/pkgs/profile-pkgs/profile-doc/info.rkt
@@ -5,6 +5,8 @@
 (define build-deps '("base"
                      "scribble-lib"
                      "profile-lib"
+                     "errortrace-doc"
+                     "errortrace-lib"
                      "racket-doc"))
 
 (define pkg-desc "documentation part of \"profile\"")
diff --git a/pkgs/profile-pkgs/profile-doc/profile/scribblings/sampler.scrbl b/pkgs/profile-pkgs/profile-doc/profile/scribblings/sampler.scrbl
index f50f95df13..b39950c0ba 100644
--- a/pkgs/profile-pkgs/profile-doc/profile/scribblings/sampler.scrbl
+++ b/pkgs/profile-pkgs/profile-doc/profile/scribblings/sampler.scrbl
@@ -1,7 +1,8 @@
 #lang scribble/doc
 
 @(require scribble/manual
-          (for-label racket/base racket/contract profile/sampler profile/analyzer))
+          (for-label racket/base racket/contract profile/sampler profile/analyzer
+                     errortrace/errortrace-key))
 
 @title[#:tag "sampler"]{Collecting Profile Information}
 
@@ -11,7 +12,8 @@
                                          (listof (or/c thread? custodian?)))]
                          [delay (>=/c 0.0)]
                          [super-cust custodian? (current-custodian)]
-                         [custom-keys (listof any/c) '()])
+                         [custom-keys (listof any/c) '()]
+                         [#:use-errortrace? use-errortrace? any/c #f])
          ((symbol?) (any/c) . ->* . any/c)]{
 
 Creates a stack-snapshot collector thread, which tracks the given
@@ -26,6 +28,10 @@ When @racket[custom-keys] are provided, the sampler takes snapshots of the
 continuation marks corresponding to the given keys, in addition to taking
 snapshots of the stack.
 
+When @racket[use-errortrace?] is not @racket[#f], the @racket[errortrace-key] is 
+used to sample snapshots instead of the implicit key used by 
+@racket[continuation-mark-set->context].
+
 The resulting value is a controller function, which consumes a message
 consisting of a symbol and an optional argument, and can affect the
 sampler.  The following messages are currently supported:
diff --git a/pkgs/profile-pkgs/profile-doc/profile/scribblings/toplevel.scrbl b/pkgs/profile-pkgs/profile-doc/profile/scribblings/toplevel.scrbl
index d4dcc3d572..3f204f08e3 100644
--- a/pkgs/profile-pkgs/profile-doc/profile/scribblings/toplevel.scrbl
+++ b/pkgs/profile-pkgs/profile-doc/profile/scribblings/toplevel.scrbl
@@ -2,6 +2,7 @@
 
 @(require scribble/manual
           (for-label racket/base racket/contract profile profile/sampler
+                     errortrace/errortrace-lib
                      (only-in profile/analyzer analyze-samples profile?)
                      (prefix-in text: profile/render-text)))
 
@@ -23,7 +24,8 @@ intended as a convenient tool for profiling code.
           [#:periodic-renderer periodic-renderer
            (or/c #f (list/c (>=/c 0.0)
                             (profile? . -> . any/c)))
-           #f])
+           #f]
+          [#:use-errortrace? use-errortrace? any/c #f])
          void?]{
 
 Executes the given @racket[thunk] and collect profiling data during
@@ -39,6 +41,14 @@ can customize the profiling:
   be close, but not identical to, the frequency in which data is
   actually sampled.  (The @racket[delay] value is passed on to
   @racket[create-sampler], which creates the sampler thread.)}
+ 
+@item{When @racket[use-errortrace?] is not @racket[#f], more accurate
+  stack snapshots are captured using 
+  @other-doc['(lib "errortrace/scribblings/errortrace.scrbl")]. Note that
+  when this is provided, it will only profile uncompiled files and files
+  compiled while using @racket[errortrace-compile-handler], and the profiled program
+  must be run using @commandline{racket -l errortrace -t program.rkt}
+  Removing compiled files (with extension @tt{.zo}) is sufficient to enable this.}
 
 @item{Due to the statistical nature of the profiler, longer executions
   result in more accurate analysis.  You can specify a number of
diff --git a/pkgs/profile-pkgs/profile-lib/info.rkt b/pkgs/profile-pkgs/profile-lib/info.rkt
index 7b91a59739..9cb70b8b80 100644
--- a/pkgs/profile-pkgs/profile-lib/info.rkt
+++ b/pkgs/profile-pkgs/profile-lib/info.rkt
@@ -1,7 +1,7 @@
 #lang info
 
 (define collection "profile")
-(define deps '("base"))
+(define deps '("base" "errortrace-lib"))
 (define build-deps '("at-exp-lib"
                      "rackunit-lib"))
 
diff --git a/pkgs/profile-pkgs/profile-lib/main.rkt b/pkgs/profile-pkgs/profile-lib/main.rkt
index 3a14dbe91e..a6bb5f932c 100644
--- a/pkgs/profile-pkgs/profile-lib/main.rkt
+++ b/pkgs/profile-pkgs/profile-lib/main.rkt
@@ -11,12 +11,14 @@
                        #:repeat  [rpt 1]
                        #:threads [threads? #f]
                        #:render  [renderer text:render]
-                       #:periodic-renderer [periodic-renderer #f])
+                       #:periodic-renderer [periodic-renderer #f]
+                       #:use-errortrace? [et? #f])
   (define cust (and threads? (make-custodian (current-custodian))))
   (define sampler (create-sampler (if threads?
                                     (list cust (current-thread))
                                     (current-thread))
-                                  delay))
+                                  delay
+                                  #:use-errortrace? et?))
   (define periodic-thread
     (and periodic-renderer
          (let ([delay (car periodic-renderer)]
diff --git a/pkgs/profile-pkgs/profile-lib/sampler.rkt b/pkgs/profile-pkgs/profile-lib/sampler.rkt
index f29b0e9faf..ddd44b0f06 100644
--- a/pkgs/profile-pkgs/profile-lib/sampler.rkt
+++ b/pkgs/profile-pkgs/profile-lib/sampler.rkt
@@ -6,8 +6,24 @@
 
 (provide create-sampler)
 
+(require errortrace/errortrace-key)
+
+;; (cons sexp srcloc) -> (cons symbol srcloc)
+;; just take the first symbol we find
+(define (errortrace-preprocess frame)
+  (cons (and (car frame)
+             (let loop ([e (car frame)])
+               (cond [(symbol? e) e]
+                     [(pair? e) (loop (car e))]
+                     [else (error 'errortrace-preprocess
+                                  "unexpected frame: ~a" frame)])))
+        (and (cdr frame)
+             (apply srcloc (cdr frame)))))
+
 ;; create-sampler : creates a sample collector thread, which tracks the given
 ;; `to-track' value every `delay' seconds.
+;; Uses errortrace annotations when #:use-errortrace? is specified, otherwise
+;;   uses the native stack traces provided by `cms->context`.
 ;; * The input value can be either a thread (track just that thread), a
 ;;   custodian (track all threads managed by the custodian), or a list of
 ;;   threads and/or custodians.  If a custodian is given, it must be
@@ -57,7 +73,8 @@
 ;;     same format as the output of continuation-mark-set->list*.
 (define (create-sampler to-track delay
                         [super-cust  (current-custodian)]
-                        [custom-keys #f])
+                        [custom-keys #f]
+                        #:use-errortrace? [do-errortrace #f])
   ;; the collected data
   (define snapshots '())
   ;; listof (cons continuation-mark-key value/#f)
@@ -116,9 +133,15 @@
                  (set! snapshots
                        (cons (list* (thread-id t)
                                     (current-process-milliseconds t)
-                                    (map intern-entry
-                                         (continuation-mark-set->context
-                                          (continuation-marks t))))
+                                    (if do-errortrace
+                                        (for/list ([frame (in-list
+                                                           (continuation-mark-set->list
+                                                            (continuation-marks t)
+                                                            errortrace-key))])
+                                            (intern-entry (errortrace-preprocess frame)))
+                                        (map intern-entry
+                                             (continuation-mark-set->context
+                                              (continuation-marks t)))))
                              snapshots)))]
               [(custodian? t)
                (for-each loop (custodian-managed-list t super-cust))]
diff --git a/pkgs/typed-racket-pkgs/source-syntax/info.rkt b/pkgs/typed-racket-pkgs/source-syntax/info.rkt
new file mode 100644
index 0000000000..a0eebe8d7e
--- /dev/null
+++ b/pkgs/typed-racket-pkgs/source-syntax/info.rkt
@@ -0,0 +1,9 @@
+#lang info
+
+(define collection "syntax")
+
+(define deps '("base"))
+
+(define pkg-desc "find mappings from expanded to source syntax")
+
+(define pkg-authors '(samth stamourv eli))
diff --git a/pkgs/typed-racket-pkgs/source-syntax/source-syntax.rkt b/pkgs/typed-racket-pkgs/source-syntax/source-syntax.rkt
new file mode 100644
index 0000000000..199b4a9409
--- /dev/null
+++ b/pkgs/typed-racket-pkgs/source-syntax/source-syntax.rkt
@@ -0,0 +1,87 @@
+#lang racket/base
+
+;; from Eli
+
+(provide recover-source-syntax)
+
+;; -------------------- utilities
+
+(define (syntax-loc stx) (list (syntax-source stx) (syntax-position stx) (syntax-span stx)))
+
+
+;; -------------------- the real stuff
+
+
+
+;; Look for `lookfor' in `enclosing', return chain of syntaxes from
+;; the innermost out of only syntaxes with the given src, returns #f
+;; if it can't find it.
+(define (enclosing-syntaxes-with-source enclosing lookfor src)
+  (let loop ([r '()] [stx enclosing])
+    ;(printf "stx is ~a\n" (syntax->datum stx))
+    ;(printf "source is ~a\n" (syntax-source stx))
+    (let* ([r* (if (and (syntax? stx) (eq? src (syntax-source stx)))
+                   (cons stx r)
+                   r)])
+      (if (eq? stx lookfor)
+          r*
+          (let ([stx (if (syntax? stx) (syntax-e stx) stx)])
+            (and (pair? stx)
+                 (or (loop r* (car stx)) (loop r* (cdr stx)))))))))
+
+
+
+
+;; Look for (the outermost) syntax in `orig' that has the same
+;; location as `lookfor' which is coming from the expanded `orig',
+;; given in `expanded'.
+(define (recover-source-syntax orig expanded)
+  (define src (syntax-source orig))
+
+  ;; this maps source locations that are from orig to their syntax
+  (define syntax-locs (make-hash))
+
+  ;; build `syntax-locs`
+  (let loop ([stx orig])
+    (when (syntax? stx) (hash-set! syntax-locs (syntax-loc stx) stx))
+    (let ([stx (if (syntax? stx) (syntax-e stx) stx)])
+      (when (pair? stx) (loop (car stx)) (loop (cdr stx)))))
+
+  ;; this maps syntax from expanded to the original
+  (define parent-table (make-hasheq))
+
+  ;; if `expanded` is mapped to something, then we'll start with it
+  (define initial-target
+      (hash-ref syntax-locs (syntax-loc expanded) #f))
+
+  ;; this searches for lookfor in orig, building up the table as we go
+  (define (add-to-table lookfor)
+    (let loop ([stx expanded] [target initial-target])
+      (cond
+       [(syntax? stx)
+	(define new-target
+	  ;; check if `stx` has the same srcloc as something in orig
+	  ;; in which case it's a good target to use
+	  ;; otherwise keep using the old target
+	  (hash-ref syntax-locs (syntax-loc stx) target))
+	;; map `stx` to the best enclosing syntax we have, if it's not already there
+	(hash-ref! parent-table stx new-target)
+	(cond
+	 ;; if we got what we came for, stop
+	 [(eq? stx lookfor) new-target]
+
+	 ;; take apart stx and loop on the components
+	 [else
+         (define stxe (syntax-e stx))
+         (and (pair? stxe)
+              (or (loop (car stxe) stx) (loop (cdr stxe) stx)))])]
+       [else #f])))
+
+  (lambda (lookfor)
+    (or
+     ;; we just might get a lookfor that is already in the original
+     (and (eq? src (syntax-source lookfor))
+          (hash-ref syntax-locs (syntax-loc lookfor) #f))
+     (hash-ref parent-table lookfor (λ ()
+                                      (add-to-table lookfor)
+                                      (hash-ref parent-table lookfor #f))))))
diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/info.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/info.rkt
index 5dbe4aab4d..524f6c0f7a 100644
--- a/pkgs/typed-racket-pkgs/typed-racket-lib/info.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-lib/info.rkt
@@ -8,6 +8,7 @@
                "pconvert-lib"
                "unstable-contract-lib"
                "unstable-list-lib"
+               "source-syntax"
                "compatibility-lib" ;; to assign types
                "string-constants-lib"))
 
diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/syntax-traversal.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/syntax-traversal.rkt
deleted file mode 100644
index 41c7354039..0000000000
--- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/syntax-traversal.rkt
+++ /dev/null
@@ -1,64 +0,0 @@
-#lang racket/base
-
-;; from Eli
-
-(provide look-for-in-orig)
-
-;; -------------------- utilities
-
-(define (syntax-loc stx) (list (syntax-source stx) (syntax-position stx) (syntax-span stx)))
-
-;; -------------------- the real stuff
-
-;; Look for `lookfor' in `enclosing', return chain of syntaxes from
-;; the innermost out of only syntaxes with the given src, returns #f
-;; if it can't find it.
-(define (enclosing-syntaxes-with-source enclosing lookfor src)
-  (let loop ([r '()] [stx enclosing])
-    ;(printf "stx is ~a\n" (syntax->datum stx))
-    ;(printf "source is ~a\n" (syntax-source stx))
-    (let* ([r (if (and (syntax? stx) (eq? src (syntax-source stx)))
-                (cons stx r)
-                r)]
-           [loop (lambda (stx) (loop r stx))])
-      (if (eq? stx lookfor)
-        r
-        (let ([stx (if (syntax? stx) (syntax-e stx) stx)])
-          (and (pair? stx)
-               (or (loop (car stx)) (loop (cdr stx)))))))))
-
-(define (unwind p)
-  (if (syntax? p)
-      (vector (vector (syntax-source p) (syntax-line p)) (unwind (syntax-e p)))
-      (if (pair? p)
-          (cons (unwind (car p)) (unwind (cdr p)))
-          p)))
-
-;; Look for (the outermost) syntax in `orig' that has the same
-;; location as `lookfor' which is coming from the expanded `orig',
-;; given in `expanded'.
-(define (look-for-in-orig orig expanded lookfor)
-  (define src (syntax-source orig))
-  ;(printf "orig : ~a\n" (unwind orig))
-  ;(printf "expanded : ~a\n" expanded)
-  ;(printf "lookfor : ~a\n" (unwind lookfor))
-  ;(printf "src : ~a\n" src)
-  (let ([enclosing (enclosing-syntaxes-with-source expanded lookfor src)]
-        [syntax-locs (make-hash)])
-    ;; find all syntax locations in original code
-    (let loop ([stx orig])
-      (when (syntax? stx) (hash-set! syntax-locs (syntax-loc stx) stx))
-      (let ([stx (if (syntax? stx) (syntax-e stx) stx)])
-        (when (pair? stx) (loop (car stx)) (loop (cdr stx)))))
-    (or
-     ;; we just might get a lookfor that is already in the original
-     (and (eq? src (syntax-source lookfor))
-          (hash-ref syntax-locs (syntax-loc lookfor) #f)
-          #;(printf "chose branch one: ~a\n" (hash-ref syntax-locs (syntax-loc lookfor) #f)))
-
-     ;; look for some enclosing expression
-     (and enclosing
-          (begin0
-            (ormap (lambda (enc) (hash-ref syntax-locs (syntax-loc enc) #f))
-                   enclosing)
-            #;(printf "chose branch two ~a\n" enclosing))))))
diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/tc-utils.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/tc-utils.rkt
index 5b5eca9c76..0a37babbf1 100644
--- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/tc-utils.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/tc-utils.rkt
@@ -6,7 +6,7 @@ don't depend on any other portion of the system
 |#
 
 (provide (all-defined-out) (all-from-out "disappeared-use.rkt"))
-(require "syntax-traversal.rkt" "disappeared-use.rkt" racket/promise
+(require syntax/source-syntax "disappeared-use.rkt" racket/promise
 	 syntax/parse (for-syntax racket/base syntax/parse) racket/match)
 
 ;; a parameter representing the original location of the syntax being
@@ -58,15 +58,18 @@ don't depend on any other portion of the system
                            (locate-stx e))
                    e))))
 
-(define (locate-stx stx)
-  (define omodule (orig-module-stx))
-  (define emodule (expanded-module-stx))
-  ;(printf "orig: ~a\n" (syntax-object->datum omodule))
-  ;(printf "exp: ~a\n" (syntax-object->datum emodule))
-  ;(printf "stx (locate): ~a\n" (syntax-object->datum stx))
-  (if (and (not (print-syntax?)) omodule emodule stx)
-      (or (look-for-in-orig omodule emodule stx) stx)
-      stx))
+(define locate-stx
+  ;; this hash handles using `locate-stx` even when orig/expand change
+  (let ([recover-table (make-hash)])
+    (lambda (stx)
+      (define omodule (orig-module-stx))
+      (define emodule (expanded-module-stx))
+      (cond [(and (not (print-syntax?)) omodule emodule stx)
+	     (define recover
+	       (hash-ref! recover-table (cons omodule emodule)
+			  (lambda () (recover-source-syntax omodule emodule))))
+	     (or (recover stx) stx)]
+	    [else stx]))))
 
 (define (raise-typecheck-error msg stxs)
   (if (null? (cdr stxs))
@@ -93,7 +96,7 @@ don't depend on any other portion of the system
     [l
      (let ([stxs
             (for/list ([e (in-list l)])
-              (with-handlers ([exn:fail:syntax? 
+              (with-handlers ([exn:fail:syntax?
                                (λ (e) ((error-display-handler) (exn-message e) e))])
                 (raise-typecheck-error (err-msg e) (err-stx e)))
               (err-stx e))])